#!/usr/bin/env perl
#$Id: filterbdlex.perl,v 1.1 2007/10/05 10:26:49 schweitz Exp $
#
# NAME
# filterbdlex.perl
#
# AUTHOR
# Franck Giron
#
# DESCRIPTION
# Generates phonetic variants from BDLEX dictionary entries

#----------------------------------------------------------------------
# perl packages
#----------------------------------------------------------------------

use lib "$ENV{HOME}/scripts/perl_libs";
use Misc;
#----------------------------------------------------------------------
#                       FUNCTIONS Description
#----------------------------------------------------------------------
# NAME
# bdlex2variants
#
# DESCRIPTION
# This function creates the possible variants of pronunciations from the
# rules defined in the french BDLex manual
#
# The following variables have to be defined in the calling routine
#    $rec     : A record containing the fields Fph and Phono

sub bdlex2variants {
    my ($rec) = @_;
    my $res = {};

    # Variants for the phonologic final

    $tmp = $rec->{Fph};

       # Specific rules

    $p = '(~|n#V|~n#V)';
    $tmp =~ s/\(~\)n[\"]/$p/;

    $p = '(|t#V|mt#V)';
    $tmp =~ s/pt[\"]/$p/;

    if ($tmp =~ m/\(kt\)\"/) {
	if ($rec->{Phono} =~ /~$/) {$tmp = '(|kt|kt#V|k|Nt|N|Nt#V)';}
	else {$tmp = '(|kt|kt#V|k)';}
    }

       # General rules

    $tmp =~ s/@(\w)[\"]/\(\(\|6\|\#V\)\|\@$1\#V\)/;
    $tmp =~ s/(\w)[\"]/\(\|$1\#V\)/;

       # Schwa rules

    $p = '(6|#V|)';
    $tmp =~ s/\@$/$p/;

    $p = '(6|)';
    $tmp =~ s/\@/$p/g;

    $res->{Fph} = $tmp;

    # Variants for the basic phonologic form

    $tmp = $rec->{Phono};

       # Optional letters

    $tmp =~ s/\((\w)\)/\($1\|\)/g;

       # Specific rules

    $p = '(|m|p)';
    $tmp =~ s/\(~p\)/$p/g;

    if ($tmp =~ /\(kt\)/) {
	if ($tmp =~ /~\(kt\)/) {
	    if ($rec->{Fph} eq 'z"') {
		$p = '(|kt|k|N|Nt)';
	    } else {
		$p = '(|kt|kt#V|k|Nt|N|Nt#V)';
	    }
	} else {
	    if ($rec->{Fph} eq 'z"') {
		$p = '(|kt|k)';    
	    } else {
		$p = '(|kt|kt#V|k)';
	    }
	}
	$tmp =~ s/\(kt\)/$p/g;
    }

    $p = '(6|)';
    $tmp =~ s/\@/$p/g;

    $p = '(aj|ai|i)';
    $tmp =~ s/\(ai\)/$p/g;

    $p = '(Ej|Ei)';
    $tmp =~ s/\(Ei\)/$p/g;

    $p = '(Ou|aU)';    
    $tmp =~ s/\(au\)/$p/g;

    $p = '(6n|En)';
    $tmp =~ s/\(6n\)/$p/g;

    $p = '(6R|ER)';
    $tmp =~ s/\(6R\)/$p/g;

    $p = '(dZ|Z)';
    $tmp =~ s/\(dZ\)/$p/g;

    $p = '(tS|S)';
    $tmp =~ s/\(tS\)/$p/g;

    $p = '(x|R|Z)';
    $tmp =~ s/\(x\)/$p/g;

    $res->{Phono} = $tmp;

    return bless $res;
}

# NAME
# expandfph
#
# DESCRIPTION
# This recursive routine expands the phonological final
#
# The following variables have to be defined in the calling routine
#    $S         : The string to expand
#    $list     : The resulting expanded list

sub expandfph {
    local ($S,$list) = @_;
    local ($head,$block,$intblock,$tail,$i,$result);
    local @alternative;

    $debug = 0;

    if ($debug) {warn "${sp}expandfph: $S\n";}

    # don't change anything if there's nothing to do
    $S =~ s/\n//;
    $result = $S;

    if ($S =~ /\(.*\)/ and ($RLENGTH = length($&), $RSTART = length($`)+1)) {
	$[ = 1;

	$head = substr( $S, 1, $RSTART - 1);
	$block = substr( $S, $RSTART+1, $RLENGTH - 2);
	$tail = substr( $S, $RSTART + $RLENGTH, 999999);

	if ($debug) {warn "$sp head=$head\tblock=$block\ttail=$tail\n";}

	while ( $block =~ /(?=\|?)[\w\#]*\([\w\|\#]*\)[\w\#]*(?=\|?)/ ) {
 	    $rlength = length($&);
 	    $rstart = length($`);
	    $intblock = $&;
	    $block = $';

	    expandfph("$head$intblock$tail",$list);
	}

	for ($i=1;$i <= (@alternative = split(/\|/, $block, 9999)); $i++) {
	    if ($debug) {warn "$sp $i \"$alternative[$i]\"\n";}
	    $result = $head . $alternative[$i] . $tail;
	    if ($debug) {warn "$sp RETURN: $result\n\n";}
	    push @{$list}, $result;
	}
    }
    else {
	if ($debug) {warn "OK $result\n";}
	push @{$list}, $result;
    }
}

# NAME
# expandphono
#
# DESCRIPTION
# This recursive routine expands the phonologic field
#
# The following variables have to be defined in the calling routine
#    $S        : The string to expand
#    $list     : The resulting expanded list

sub expandphono {
    local ($S,$list) = @_;
    local ($head,$intblock,$tail,$i,$result,$block);
    local @alternative;

    $debug = 0;

    if ($debug) {warn "${sp}expandphono: $S\n";}

    # don't change anything if there's nothing to do
    $S =~ s/\n//;
    $result = $S;

    if ( ($S =~ /\([\w\|\#]*\(?[\w\|\#]*\)?[\w\|\#]*(?=\|?)\)/)
	&& ($RLENGTH = length($&), $RSTART = length($`)+1) ) {

	$[ = 1;

	$head = substr( $S, 1, $RSTART - 1);
	$block = substr( $S, $RSTART+1, $RLENGTH - 2);
	$tail = substr( $S, $RSTART + $RLENGTH, 999999);

	if ($debug) {warn "$sp head=$head\tblock=$block\ttail=$tail\n";}

 	while ( $block =~ /(?=\|?)[\w\#]*\([\w\|\#]*\)[\w\#]*(?=\|?)/ ) {
 	    $rlength = length($&);
 	    $rstart = length($`);
 	    $intblock = $&;
 	    $block = $';	    

	    if ($debug) {warn "$sp intblock = $intblock\t nextblock=$block\n";}

	    expandphono("$head$intblock$tail",$list);

	    $sp .= "   ";
	}

 	if ($debug) {warn "$sp block:$block.\n";}

	if ($block =~ /^\|(\w*)$/) {
	    $block = $1;
	    if ($tail =~  /[\(\)]/) {
		$sp .= "   ";
		expandphono("$head$block$tail",$list);
	    } else {
		$result = $head . $1 . $tail;
		push @{$list}, $result;
	    }
	} else {
	    for ($i=1;$i <= (@alternative = split(/\|/, $block,9999)); $i++) {
		    if ($debug) {warn "$sp $i \"$alternative[$i]\"\n";}

		    if ($tail =~ /[\(\)]/ ) {
			$sp .= "   ";
			expandphono("$head$alternative[$i]$tail",$list);
		    } else {
			$result = $head . $alternative[$i] . $tail;
			if ($debug) {warn "$sp RETURN: $result\n\n";}
			push @{$list}, $result;
		    }
 	    }
 	}
	$sp .= "\b\b\b";
    }   else {
	if ($debug) {
	    warn "OK $result\n";
	}
	push @{$list}, $result;
    }
}

#----------------------------------------------------------------------
#                       MAIN program
#----------------------------------------------------------------------

# Initialisations
# Hash of BDLex letters with accent for conversion to Iso
$txt2iso = genacc2iso();
@txt2iso_let = keys %{$txt2iso};
$pattern = join('',@txt2iso_let);

# Search file list of BDLex files
$BDROOT = '/speech/db/fra/bdlex/B50';
#open FILELIST, "ls $BDROOT/*.B50.flx|";
open FILELIST, "ls $ARGV[0].flx|";

$debug_var = 0;

# Treat the file list
while (<FILELIST>) {
    chop;
    $file = $_;
    warn "->$file\n";

    open FILE, "<$file";

    # Store each entry in a big hash
    while (<FILE>) {
	($Graphie,$Phono,$Fph,$Cs,$C5,$C6,$Lien) = split /;/;

	if ($debug_var) {warn "tested: $Graphie,$Phono,$Fph,$Cs,$C5,$C6,$Lien";}

	# Test existence of previous version of the Graphie
	if (exists $list{$Graphie}) {
	  LOOPV: for $v (0 .. $list{$Graphie}{Var}) {
	      $vs = $v ? $Graphie . '/' . $v : $Graphie;
	      $Phonov = $list{$vs}{Phono};
	      $Fphv = $list{$vs}{Fph};

	      if ($debug_var) {warn "cmp: $vs $Phonov:$Phono $Fphv:$Fph\n";}

	      if ($Fph ne '' and $Fph ne $Fphv) {
		  if ($Fph =~ /\"/ and $Fphv eq '') {
		      if ($debug_var) {warn ">overwrite\n";}
		      $vs = $Graphie;
		      last LOOPV;
		  } else {
		      if ($Fph =~ /$Fphv/) {
			  if ($debug_var) {warn "v=$Fphv in $Fph\n";}
			  last LOOPV;
		      }
		      if ($Fphv =~ /$Fph/) {
			  if ($debug_var) {warn "$Fph in v=$Fphv\n";}
			  $Phono = $Phonov;
			  $Fph = $Fphv;
			  last LOOPV;
		      }
		      if ($debug_var) {warn ">new\n";}
		      $list{$Graphie}{Var}++;
		      $vs = $Graphie. '/'. $list{$Graphie}{Var};
		      last LOOPV;
		  }
	      } else {
		  if ($Phono ne $Phonov) {
		      $list{$Graphie}{Var}++;
		      $vs = $Graphie. '/'. $list{$Graphie}{Var};
		      if ($debug_var) {warn "new Phono entry: $vs,$Phono,$Fph.\n";}
		  }
		  last LOOPV;
	      }
	  }
	    if ($debug_var) {warn "var written: $vs,$Phono,$Fph.\n";}
	    $list{$vs}{Phono}  = $Phono;
	    $list{$vs}{Fph}  = $Fph;

	} 
	# Create a  new version
	else {
	    if ($debug_var) {warn "new entry: $Graphie,$Phono,$Fph.\n";}
	    $list{$Graphie}{Phono} = $Phono;
	    $list{$Graphie}{Fph}   = $Fph;
	}
    }
    close FILE;

    @klist = sort keys %list;

  LOOP: while ( $Graphie = shift @klist) {
      if ($Graphie =~ /_/ or $Graphie =~ /\/\d+$/) {next LOOP;}

      # Convert the bdlex accent format to iso
      $Graphie_iso = acc2iso($pattern,$txt2iso,$Graphie);

      # Test if many variants of the Graphie are existent
      if (exists $list{$Graphie}{Var}) {
	  for $v (0 .. $list{$Graphie}{Var}) {
	      $vs = $v ? $Graphie . '/' . $v : $Graphie;
	      $elem = $list{$vs};

	      # Generate possible variants
	      $var = bdlex2variants($elem);

	      # Expand Fph and Phono fields
	      $fphlist = [];
	      expandfph($var->{Fph},$fphlist);
	      $phonolist = [];
	      expandphono($var->{Phono},$phonolist);

	      # Create possible variants
	      foreach $Phono (@{$phonolist}) {
		  foreach $Fph (@{$fphlist}) {
		      $exp = $Phono . $Fph;
		      # Adjust to sampa
		      $exp =~ s/A~/a~/g;
		      $exp =~ s/E~/e~/g;
		      $exp =~ s/O~/o~/g;
		      push @varlist,$exp;
		  }
	      }

	      # And excludes identical ones
	      @varlistsort = sort @varlist;
	      @varlist = uniq @varlistsort;
	      undef @varlistsort;
	  }
      } else {
	  $elem = $list{$Graphie};

	  # Generate possible variants
	  $var = bdlex2variants($elem);

	  # Expand Fph and Phono field
	  $fphlist = [];
	  expandfph($var->{Fph},$fphlist);
	  $phonolist = [];
	  expandphono($var->{Phono},$phonolist);

	  # Create possible variants
	  foreach $Phono (@{$phonolist}) {
	      foreach $Fph (@{$fphlist}) {
		  $exp = $Phono . $Fph;
		  push @varlist,$exp;
	      }
	  }
      }

      # Create the final expression
      $exp = '';

      foreach (@varlist) {
	  $exp .= '['. $_ . ']<|>';
      }

      if ($#varlist > 1) {
	  $exp =~ s/\<\|\>$/\<\)\>/;
	  $exp = '<(>' . $exp;
      } else {
	  $exp =~ s/\<\|\>$//;
      }

      # And print it to stdout
      print "$Graphie_iso!$exp!\n";
      undef $fphlist;
      undef $phonolist;
      undef @varlist;
  }
    #undef the lists for reuse by the next file
    undef $list;
    undef %list;
}

close FILELIST;

